home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / ada / adaed-1.11 / adaed-1 / Adaed-1.11.0a / 3a.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-02-07  |  59.0 KB  |  1,995 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9.  
  10. #include "3.h"
  11. #include "attr.h"
  12. #include "arithprots.h"
  13. #include "miscprots.h"
  14. #include "smiscprots.h"
  15. #include "dclmapprots.h"
  16. #include "nodesprots.h"
  17. #include "errmsgprots.h"
  18. #include "evalprots.h"
  19. #include "setprots.h"
  20. #include "chapprots.h"
  21.  
  22. extern int *ADA_MIN_FIXED_MP, *ADA_MAX_FIXED_MP;
  23.  
  24. static void const_redecl(Node, Node, Node);
  25. static Symbol set_type_mark(Tuple, Node);
  26. static void build_type(Symbol, Node, Node);
  27. static void derived_type(Symbol, Node);
  28. static void build_derived_type(Symbol, Symbol, Node);
  29. static int in_unconstrained_natures(int);
  30. static int is_derived_type(Symbol);
  31. static void derive_subprograms(Symbol, Symbol);
  32. static void derive1_subprogram(Symbol, Symbol, Symbol, Symbol);
  33. static int hidden_derived(Symbol, Symbol);
  34. static Symbol find_neq(Symbol);
  35. static void new_enum_type(Symbol, Node);
  36. static void new_integer_type(Symbol, Node);
  37. static void new_floating_type(Symbol, Node);
  38. static void new_fixed_type(Symbol, Node);
  39. static Node real_bound(Node, Symbol);
  40. static Symbol constrain_scalar(Symbol, Node);
  41.  
  42. void obj_decl(Node node)                                     /*;obj_decl*/
  43. {
  44.     /* Process variable declaration. Verify that the type is a constrained one,
  45.      * or that default values exist for the discriminants of the type.
  46.      */
  47.  
  48.     Node id_list_node, type_indic_node, init_node, id_node, node1;
  49.     Symbol    type_mark, t_m, n;
  50.     int i;
  51.     Tuple    nam_list, id_nodes;
  52.     Fortup    ft1;
  53.  
  54.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : obj_decl");
  55.  
  56.     id_list_node  = N_AST1(node);
  57.     type_indic_node     = N_AST2(node);
  58.     init_node = N_AST3(node);
  59.  
  60.     id_nodes = N_LIST(id_list_node);
  61.     nam_list = tup_new(tup_size(id_nodes));
  62.     FORTUPI(id_node =(Node) , id_nodes, i,  ft1);
  63.         nam_list[i] = (char *) find_new(N_VAL(id_node));
  64.     ENDFORTUP(ft1);
  65.     type_mark = set_type_mark(nam_list, type_indic_node);
  66.  
  67.     current_node = type_indic_node;
  68.     check_fully_declared(type_mark);
  69.     adasem(init_node);
  70.  
  71.     /* If an initialization is provided, verify it has the specified type.  */
  72.     if (init_node != OPT_NODE)
  73.         t_m = check_init(type_indic_node, init_node);
  74.  
  75.     if (is_unconstrained(type_mark)) {
  76. #ifdef ERRNUM
  77.         nat_errmsgn(131, type_mark, 132, type_indic_node);
  78. #else
  79.         errmsg_nat("Unconstrained % in object declaration", type_mark,
  80.           "3.6.1, 3.7.2", type_indic_node);
  81. #endif
  82.     }
  83.  
  84.     /*(forall n in nam_list) nature(n) := na_obj; end forall;*/
  85.     FORTUP(n=(Symbol), nam_list, ft1);
  86.         NATURE(n) = na_obj;
  87.     ENDFORTUP(ft1);
  88.     for (i = 1; i <= tup_size(id_nodes); i++) {
  89.         node1 = (Node) id_nodes[i];
  90.         N_UNQ(node1) = (Symbol) nam_list[i];
  91.     }
  92. }
  93.  
  94. void const_decl(Node node)                              /*;const_decl*/
  95. {
  96.     /* Process constant declarations. This may be a new declaration, or the
  97.      * full declaration of a deferred constant in the private part of a
  98.      * package. In this later case, recover the names of the constants, and
  99.      * update their definitions.
  100.      */
  101.  
  102.     Node    id_list_node, type_indic_node, init_node, id_node;
  103.     Tuple    id_nodes, id_list, nam_list;
  104.     Symbol    type_mark, t_m, n;
  105.     char    *id;
  106.     int    i, exists;
  107.     Fortup    ft1;
  108.     Symbol    s;
  109.  
  110.     if (cdebug2 > 3)  TO_ERRFILE("AT PROC : const_decl");
  111.  
  112.     id_list_node = N_AST1(node);
  113.     type_indic_node = N_AST2(node);
  114.     init_node = N_AST3(node);
  115.  
  116.     id_nodes = N_LIST(id_list_node);
  117.     id_list = tup_new(tup_size(id_nodes));
  118.     FORTUPI(id_node =(Node), id_nodes, i, ft1);
  119.         id_list[i] = N_VAL(id_node);
  120.     ENDFORTUP(ft1);
  121.     adasem(init_node);
  122.  
  123.     if (NATURE(scope_name) == na_private_part) {
  124.         exists = FALSE;
  125.         FORTUP(id=, id_list, ft1);
  126.             if (dcl_get(DECLARED(scope_name), id) != (Symbol)0) {
  127.                 exists = TRUE;
  128.                 break;
  129.             }
  130.         ENDFORTUP(ft1);
  131.         if (exists ){
  132.             /* It must be a deferred constant. */
  133.             const_redecl(id_list_node, type_indic_node, init_node);
  134.             return;
  135.             /* Otherwise it is a fully private constant. */
  136.         }
  137.     }
  138.  
  139.     nam_list = tup_new(tup_size(id_list));
  140.     FORTUPI(id =, id_list, i, ft1);
  141.         nam_list[i] = (char *) find_new(id);
  142.     ENDFORTUP(ft1);
  143.  
  144.     type_mark = set_type_mark(nam_list, type_indic_node);
  145.  
  146.     if (init_node == OPT_NODE) {
  147.         /* Deferred constant.*/
  148.         s = TYPE_OF(base_type(type_mark));
  149.         if (s != symbol_private && s != symbol_limited_private) {
  150. #ifdef ERRNUM
  151.             errmsgn(133, 134, node);
  152. #else
  153.             errmsg("Missing initialization in constant declaration", "3.2",
  154.               node);
  155. #endif
  156.         }
  157.         else if (SCOPE_OF(type_mark) != scope_name) {
  158. #ifdef ERRNUM
  159.             errmsgn(135, 136, type_indic_node);
  160. #else
  161.             errmsg("Wrong scope for type of deferred constant", "7.4",
  162.               type_indic_node);
  163. #endif
  164.         }
  165.         else if ( (NATURE(scope_name) != na_package_spec)
  166.           && (NATURE(scope_name) != na_generic_package_spec) ) {
  167. #ifdef ERRNUM
  168.             errmsgn(137, 138, node);
  169. #else
  170.             errmsg("Invalid context for deferred constant", "3.2, 7.4", node);
  171. #endif
  172.         }
  173.         else if (is_generic_type(type_mark)
  174.           || is_generic_type(base_type(type_mark))) { 
  175. #ifdef ERRNUM
  176.             errmsgn(139, 48, node);
  177. #else
  178.             errmsg("constants of a generic type cannot be deferred", "12.1.2",
  179.               node);
  180. #endif
  181.         }
  182.         else if (is_anonymous(type_mark)) {
  183. #ifdef ERRNUM
  184.             errmsgn(140, 43, node);
  185. #else
  186.             errmsg("a deferred constant must be defined with a type mark",
  187.               "7.4.3", node);
  188. #endif
  189.         }
  190.     }
  191.     else {
  192.         t_m = check_init(type_indic_node, init_node);
  193.  
  194.         if (t_m != type_mark) {
  195.             /* t_m is an anonymous type created from the bounds of init value*/
  196.             FORTUP(n = (Symbol), nam_list, ft1);
  197.                 TYPE_OF(n) = t_m;
  198.             ENDFORTUP(ft1);
  199.         }
  200.     }
  201.  
  202.     FORTUP(n =(Symbol), nam_list, ft1);
  203.         NATURE(n) = na_constant;
  204.         SIGNATURE(n) = (Tuple) init_node;
  205.     ENDFORTUP(ft1);
  206.     for (i = 1; i <= tup_size(id_nodes); i++) {
  207.         Node tmp = (Node) id_nodes[i];
  208.         N_UNQ(tmp) = (Symbol) nam_list[i];
  209.     }
  210. }
  211.  
  212. static void const_redecl(Node id_list_node, Node type_indic_node,
  213.   Node init_node)                                             /*;const_redecl*/
  214. {
  215.     /* Process the full declaration of deferred constants. at least one id
  216.      * in  id_list is know to have been declared in the visible part of the
  217.      * current scope.
  218.      */
  219.  
  220.     Symbol    u_n, t_m, type_mark;
  221.     Symbol    ut;
  222.     Node    id_node, tmp;
  223.     Tuple    id_nodes, nam_list, id_list;
  224.     char    *id;
  225.     int    i;
  226.     Fortup    ft1;
  227.  
  228.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : const_redecl");
  229.  
  230.     id_nodes = N_LIST(id_list_node);
  231.     id_list = tup_new(tup_size(id_nodes));
  232.     FORTUPI(id_node =(Node), id_nodes, i, ft1);
  233.         id_list[i]  = N_VAL(id_node);
  234.     ENDFORTUP(ft1);
  235.     nam_list = tup_new(0);
  236.     /* The type indication must be a subtype indication .*/
  237.  
  238.     if (N_KIND(type_indic_node) == as_subtype_indic) {
  239.         adasem(type_indic_node);
  240.         type_mark = promote_subtype(make_subtype(type_indic_node));
  241.     }
  242.     else
  243.         /* An anonymous array is syntactically possible, but incorrect. */
  244.         type_mark = anonymous_array(type_indic_node);
  245.  
  246.     N_UNQ(type_indic_node) = type_mark;
  247.  
  248.     FORTUP(id =, id_list, ft1);
  249.         u_n = dcl_get(DECLARED(scope_name), id);
  250.         if (u_n == (Symbol)0) {
  251. #ifdef ERRNUM
  252.             str_errmsgn(141, id, 138, id_list_node);
  253. #else
  254.             errmsg_str("% is not a deferred constant", id, "3.2, 7.4",
  255.               id_list_node);
  256. #endif
  257.             nam_list = tup_with(nam_list, (char *)symbol_any);
  258.             continue;
  259.         }
  260.         else if((NATURE(u_n) != na_constant)
  261.           || ((Node) SIGNATURE(u_n) != OPT_NODE)) {
  262. #ifdef ERRNUM
  263.             str_errmsgn(142, id, 143, id_list_node);
  264. #else
  265.             errmsg_str("Invalid redeclaration of %", id, "8.3", id_list_node);
  266. #endif
  267.             nam_list = tup_with(nam_list, (char *)symbol_any);
  268.             continue;
  269.         }
  270.         else if ( ((ut = TYPE_OF(u_n)) != type_mark)
  271.           /* They may still be the same subtype of some private type.*/
  272.           && (TYPE_OF(ut) != TYPE_OF(type_mark))
  273.           || (SIGNATURE(ut) != SIGNATURE(type_mark)))
  274.         {
  275. #ifdef ERRNUM
  276.             str_errmsgn(144, id, 145, id_list_node);
  277. #else
  278.             errmsg_str("incorrect type in redeclaration of %", id,
  279.               "7.4, 7.4.1", id_list_node);
  280. #endif
  281.             nam_list = tup_with(nam_list, (char *)symbol_any);
  282.         }
  283.         else if (init_node == OPT_NODE) {    /* No initiali(zation ? */
  284. #ifdef ERRNUM
  285.             str_errmsgn(146, id, 136, id_list_node);
  286. #else
  287.             errmsg_str("Missing initialization in redeclaration of %", id,
  288.               "7.4", id_list_node);
  289. #endif
  290.             nam_list = tup_with(nam_list, (char *)symbol_any);
  291.         }
  292.         else {
  293.             TO_XREF(u_n);
  294.             nam_list = tup_with(nam_list, (char *)  u_n);
  295.         }
  296.     ENDFORTUP(ft1);
  297.  
  298.     for (i = 1; i <= tup_size(id_nodes); i++) {
  299.         tmp = (Node) id_nodes[i];
  300.         N_UNQ(tmp ) = (Symbol) nam_list[i];
  301.     }
  302.  
  303.     if (init_node != OPT_NODE ) {
  304.         t_m = check_init(type_indic_node, init_node);
  305.         FORTUP(u_n=(Symbol), nam_list, ft1);
  306.             SIGNATURE(u_n) = (Tuple) init_node;
  307.         ENDFORTUP(ft1);
  308.     }
  309. }
  310.  
  311. static Symbol set_type_mark(Tuple nam_list, Node type_indic_node)
  312.                                                             /*;set_type_mark*/
  313. {
  314.     /* Set the symbol table entry for object or constant declarations.
  315.      * The type indication is a subtype indication or an array definition. In
  316.      * the later case, an anonymous array type must be created for each item
  317.      * in the name list. For the interpreter, any of these types will do.
  318.      */
  319.  
  320.     Symbol    type_mark, n;
  321.     Fortup    ft1;
  322.  
  323.     if (N_KIND(type_indic_node) == as_subtype_indic) {
  324.         adasem(type_indic_node);
  325.         type_mark = promote_subtype(make_subtype(type_indic_node));
  326.         FORTUP(n=(Symbol), nam_list, ft1);
  327.             TYPE_OF(n) = type_mark;
  328.         ENDFORTUP(ft1);
  329.     }
  330.     else {
  331.         n = (Symbol) nam_list[1];
  332.         type_mark = anonymous_array(type_indic_node);
  333.         TYPE_OF(n) = type_mark;
  334.     }
  335.  
  336.     N_UNQ(type_indic_node) = type_mark;
  337.     return type_mark;
  338. }
  339.  
  340. Symbol check_init(Node type_indic_node, Node init_node)    /*;check_init*/
  341. {
  342.     /* Validate the initialization of an object or constant declaration.
  343.      * Return the resolved expression, and the type (or a subtype of it
  344.      * in the case of constants of unconstrained type).
  345.      */
  346.     Symbol    type_mark;
  347.     Tuple    init_array;
  348.     Fortup    ft1;
  349.     int    lo_val, hi_val;
  350.     Tuple    new_indices, tup;
  351.     Symbol    index, new_index, new_array;
  352.     Node    lo, hi;
  353.  
  354.     type_mark = N_UNQ(type_indic_node);
  355.  
  356.     if (is_limited_type(type_mark)) {
  357. #ifdef ERRNUM
  358.         errmsgn(147, 34, type_indic_node);
  359. #else
  360.         errmsg("Initialization not available for entities of limited type",
  361.           "7.4.4", type_indic_node);
  362. #endif
  363.     }
  364.  
  365.     check_type(type_mark, init_node);
  366.  
  367.     if (NATURE(type_mark) == na_array && type_mark == symbol_string
  368.       && (N_KIND(init_node) == as_string_ivalue )) {
  369.         /* Constant definition with unconstrained type: bounds are given by 
  370.             * an aggregate :  Create an anonymous subtype using  bounds of
  371.          * aggregate.  Currently supported for strings only. 
  372.          */
  373.         init_array = (Tuple) N_VAL(init_node);
  374.  
  375.         new_indices = tup_new(0);
  376.         /* Unpack aggregate to obtain actual bounds on each dimension,
  377.          * and create constrained index for each.
  378.          * TBSL.
  379.          */
  380.         FORTUP(index=(Symbol), (Tuple)index_types(type_mark), ft1);
  381.             if (N_KIND(init_node) == as_string_ivalue  
  382.                  && base_type(type_mark) == symbol_string) {
  383.                 lo_val = 1;
  384.                 hi_val = tup_size( init_array);
  385.             }
  386.             else
  387.                 tup = init_array;
  388.                 /* TBSL */
  389.  
  390.             new_index = anonymous_type(); /* Its new subtype. */
  391.  
  392.             lo = new_ivalue_node(int_const(lo_val), symbol_integer);
  393.             hi = new_ivalue_node(int_const(hi_val), symbol_integer);
  394.  
  395.             NATURE(new_index)  = na_subtype;
  396.             TYPE_OF(new_index) = index;
  397.             { 
  398.                 Tuple t;
  399.                 t = constraint_new(CONSTRAINT_RANGE);
  400.                 numeric_constraint_low(t) = (char *) lo;
  401.                 numeric_constraint_high(t) = (char *) hi;
  402.                 SIGNATURE(new_index) = (Tuple) t;
  403.             }
  404.             root_type(new_index) = root_type(index);
  405.             new_indices = tup_with(new_indices, (char *) new_index);
  406.         ENDFORTUP(ft1);
  407.         new_array = anonymous_type();
  408.         NATURE(new_array) = na_subtype;
  409.         TYPE_OF(new_array) = type_mark;
  410.         { 
  411.             Tuple t; 
  412.             t = tup_new(2);
  413.             t[1] = (char *) new_indices;
  414.             t[2] = (char *) component_type(type_mark);
  415.             SIGNATURE(new_array) = t;
  416.         };
  417.         root_type(new_array) = root_type(type_mark);
  418.         misc_type_attributes(new_array) = misc_type_attributes(type_mark);
  419.  
  420.         type_mark = new_array;
  421.         N_TYPE(init_node) = type_mark;
  422.         N_UNQ(type_indic_node) = type_mark;
  423.     }
  424.     return type_mark;
  425. }
  426.  
  427. int is_deferred_constant(Node con_node)                /*;is_deferred_constant*/
  428. {
  429.     return
  430.       (N_KIND(con_node) == as_simple_name)
  431.       && (NATURE(N_UNQ(con_node)) == na_constant)
  432.       && ((Node) SIGNATURE(N_UNQ(con_node)) == OPT_NODE);
  433. }
  434.  
  435. void number_decl(Node node) /*;number_decl*/
  436. {
  437.     /* A number declaration differs from a constant declaration in that
  438.      * the type of the declared object is a universal numeric type, obtained
  439.      * from the value of the  literal expression supplied for it.
  440.      * No intermediate code is generated for these: they act as macros,
  441.      * and are always represented by their value.
  442.      */
  443.  
  444.     Node    id_list_node, expn, id_node;
  445.     Symbol    number_type, n;
  446.     Tuple    nam_list;
  447.     Fortup    ft1;
  448.     int    i;
  449.  
  450.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : number_decl");
  451.  
  452.     id_list_node = N_AST1(node);
  453.     expn = N_AST2(node);
  454.  
  455.     nam_list = tup_new(tup_size(N_LIST(id_list_node)));
  456.     FORTUPI(id_node =(Node), N_LIST(id_list_node), i, ft1);
  457.         nam_list[i] = (char *)find_new(N_VAL(id_node));
  458.     ENDFORTUP(ft1);
  459.     adasem(expn);
  460.     check_type_u( expn);
  461.     number_type = N_TYPE(expn);
  462.     if (! is_static_expr(expn)) {
  463. #ifdef ERRNUM
  464.         errmsgn(148, 134, expn);
  465. #else
  466.         errmsg("Expect literal expression in number declaration", "3.2", expn);
  467. #endif
  468.         number_type = symbol_any;
  469.     }
  470.  
  471.     FORTUP(n=(Symbol), nam_list, ft1);
  472.         /*??SYMBTAB(n) = [na_constant, number_type, expn];*/
  473.         NATURE(n) = na_constant;
  474.         TYPE_OF(n) = number_type;
  475.         SIGNATURE(n) = (Tuple) expn;
  476.     ENDFORTUP(ft1);
  477. }
  478.  
  479. void type_decl(Node node)     /*;type_decl*/
  480. {
  481.     /* Process a type declaration. Create new name for type, or find unique
  482.      * name already given for incomplete declaration.
  483.      */
  484.  
  485.     Node    id_node, opt_disc, type_def;
  486.     Symbol    type_name, kind, d_type;
  487.  
  488.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : type_decl");
  489.  
  490.     id_node = N_AST1(node);
  491.     opt_disc = N_AST2(node);
  492.     type_def  = N_AST3(node);
  493.  
  494.     type_name = find_type_name(id_node);
  495.     sem_list(opt_disc);
  496.  
  497.     if (type_name == symbol_any) return;    /* Invalid redeclaration, etc. */
  498.  
  499.     root_type(type_name) = type_name;     /* initial value */
  500.  
  501.     if (opt_disc != OPT_NODE) {
  502.         if ( in_incp_types(TYPE_OF(type_name)))
  503.             /* Full declaration of incomplete or private type. Verify that
  504.              * discriminant declarations are conforming .
  505.              */
  506.             discr_redecl(type_name, opt_disc);
  507.         else if (N_KIND(type_def) == as_derived_type)
  508.             NATURE(type_name) = na_record;
  509.     }
  510.     else if (in_incp_types(TYPE_OF(type_name)) && has_discriminants(type_name)){
  511. #ifdef ERRNUM
  512.         errmsgn(151, 152, node);
  513. #else
  514.         errmsg("missing discriminants in full type declaration", "3.8", node);
  515. #endif
  516.     }
  517.  
  518.     kind = TYPE_OF(type_name);
  519.  
  520.     build_type(type_name, opt_disc, type_def);
  521.  
  522.     if (opt_disc != OPT_NODE && !is_record(type_name)) {
  523. #ifdef ERRNUM
  524.         errmsgn(149, 150, opt_disc);
  525. #else
  526.         errmsg("Invalid use of discriminants", "3.7.1", opt_disc);
  527. #endif
  528.     }
  529.     if ((N_KIND(type_def) == as_int_type || N_KIND(type_def) == as_float_type
  530.       || N_KIND(type_def) == as_fixed_type)
  531.       ||( N_KIND(type_def) == as_derived_type
  532.       && NATURE(type_name) == na_subtype)) {
  533.         /* these declarations generate an anonyous parent type. The named
  534.          * type is actually a subtype.
  535.          */
  536.         N_KIND(node) = as_subtype_decl;
  537.         /* preserve subtype info in n_ast3 by moving to n_ast2 
  538.          * Since none of these types have a discriminant 
  539.          * no information is lost.
  540.          */
  541.         N_AST2(node) = N_AST3(node);
  542.         N_AST3(node) = (Node)0; /* subtype_decl has no n_ast3 */
  543.     }
  544.     current_node = id_node;
  545.     /* recall that priv_types is {limited, limited_private} */
  546.     /* check_priv_decl first argument is one of MISC_TYPE_ATTRIBUTE ...*/
  547.     if (kind == symbol_private)
  548.         check_priv_decl(TA_PRIVATE, type_name);
  549.     else if (kind == symbol_limited_private)
  550.         check_priv_decl(TA_LIMITED_PRIVATE, type_name);
  551.  
  552.     else if (kind == symbol_incomplete && S_UNIT(type_name) != unit_number_now){
  553.         /* case of an incomplete type in the private part of a package, whose
  554.          * complete definition is given in the package body. Create a dummy
  555.          * symbol to which the complete definition is attached. The expander
  556.          * retrieves it and updates the symbol table of type_name accordingly.
  557.          */
  558.         d_type = sym_new(NATURE(type_name));
  559.         N_TYPE(node) = d_type;
  560.         TYPE_OF(d_type)    = TYPE_OF(type_name);
  561.         SIGNATURE(d_type) = SIGNATURE(type_name);
  562.         OVERLOADS(d_type) = OVERLOADS(type_name);
  563.         SCOPE_OF(d_type) = scope_name;
  564.         root_type(d_type) = root_type(type_name);
  565.         dcl_put(DECLARED(scope_name), newat_str(), d_type);
  566.     }
  567.     check_delayed_type(node, type_name);  /* if it has a private ancestor. */
  568. }
  569.  
  570. Symbol find_type_name(Node id_node)                 /*;find_type_name*/
  571. {
  572.     /* Create a unique  name for a type  definition, or find  the unique name
  573.      * already created, in the case of the    full declaration of an incomplete
  574.      * or  private type. 
  575.      */
  576.  
  577.     char    *id;
  578.     Symbol    incomplete, type_name, a_t;
  579.     Forset fs1;
  580.  
  581.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : find_type_name");
  582.  
  583.     id = N_VAL(id_node);
  584.  
  585.     /* Find incomplete declaration, if some was given. */
  586.  
  587.     incomplete = dcl_get(DECLARED(scope_name), id);
  588.  
  589.     if (incomplete == (Symbol)0)        /* New type declaration. */
  590.         type_name = find_new(id);
  591.     else {                                /* Previous declaration exists.*/
  592.         if (id != (char *)0 && streq(id, "any_id")) {
  593.             /* any_id identifier was inserted (by parser) */
  594.             N_UNQ(id_node) = symbol_any;
  595.             return symbol_any;
  596.         }
  597.         type_name = incomplete;
  598.         TO_XREF(incomplete);
  599.         if (!in_incp_types(TYPE_OF(incomplete))) {
  600. #ifdef ERRNUM
  601.             str_errmsgn(142, id, 143, id_node);
  602. #else
  603.             errmsg_str("Invalid redeclaration of %", id, "8.3", id_node);
  604. #endif
  605.             type_name = symbol_any;
  606.         }
  607.         if (TYPE_OF(incomplete) == symbol_incomplete) {
  608.             if(private_dependents(incomplete)) {
  609.                 FORSET(a_t = (Symbol), private_dependents(incomplete), fs1)
  610.                     if (is_access(a_t) && SCOPE_OF(a_t) == scope_name)
  611.                         /* access type is now dereferenceable.*/
  612.                         misc_type_attributes(a_t)
  613.                           = (int) misc_type_attributes(a_t) & ~TA_INCOMPLETE;
  614.                 ENDFORSET(fs1)
  615.             }
  616.         }
  617.         else {
  618.             /* Full declaration for private type. Save visible declaration in
  619.              * private decls for this package, so that full declaration can
  620.              * be installed.
  621.              */
  622.             private_decls_put((Private_declarations) private_decls(scope_name),
  623.               type_name);
  624.  
  625.             if (is_generic_type(incomplete)) {
  626. #ifdef ERRNUM
  627.                 l_str_errmsgn(156, 157, id, 56, id_node);
  628. #else
  629.                 errmsg_l_str("Generic private type % cannot have declaration ",
  630.                   "in private part", id, "12.1", id_node);
  631. #endif
  632.                 type_name = symbol_any;
  633.             }
  634.         }
  635.     }
  636.     N_UNQ(id_node) = type_name;
  637.     return type_name;
  638. }
  639.  
  640. static void build_type(Symbol type_name, Node opt_disc, Node type_def)
  641.                                                                 /*;build_type*/
  642. {
  643.     /* For scalar types, both generic and non-generic, this procedure  simply
  644.      * constructs the symbol table entry on the basis of the type definition.
  645.      * Enumeration    types, array  types and     derived  types     require  further
  646.      * processing. They generate additional symbol table entries for literals
  647.      * and anonymous types.
  648.      */
  649.  
  650.     Symbol    parent, desig_type;
  651.     int    l;
  652.     Node    type_indic_node;
  653.  
  654.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : build_type");
  655.  
  656.     switch (N_KIND(type_def)) {
  657.     case as_enum:
  658.         new_enum_type(type_name, type_def);
  659.         break;
  660.     case as_int_type:
  661.         new_integer_type(type_name, type_def);
  662.         break;
  663.     case as_float_type:
  664.         new_floating_type(type_name, type_def);
  665.         break;
  666.     case as_fixed_type:
  667.         new_fixed_type(type_name, type_def);
  668.         break;
  669.     case as_array_type:
  670.         new_array_type(type_name, type_def);
  671.         break;
  672.     case as_record:
  673.         record_decl(type_name, opt_disc, type_def);
  674.         break;
  675.     case as_derived_type:
  676.         derived_type(type_name, type_def);
  677.         break;
  678.     case as_access_type:
  679.         adasem(type_def);
  680.         type_indic_node = N_AST1(type_def);
  681.         desig_type = N_UNQ(type_indic_node);
  682.         if (type_name == desig_type)
  683. #ifdef ERRNUM
  684.             id_errmsgn(158, type_name, 5, type_indic_node);
  685. #else
  686.         errmsg_id("Invalid use of type % before its full declaration",
  687.           type_name, "3.8.1", type_indic_node);
  688. #endif
  689.         /*??SYMBTAB(type_name) :=[na_access, type_name, desig_type];*/
  690.         NATURE(type_name)    = na_access;
  691.         TYPE_OF(type_name)   = type_name;
  692.         SIGNATURE(type_name) = (Tuple) desig_type;
  693.         new_agg_or_access_acc(type_name);
  694.         break;
  695.     }
  696.     /* The new type inherits the root type and other attributes of its parent */
  697.  
  698.     parent = TYPE_OF(type_name);
  699.  
  700.     /*root_type(type_name) = root_type(parent) ? parent;*/
  701.     if (root_type(parent) != (Symbol)0)
  702.         root_type(type_name) = root_type(parent);
  703.     else root_type(type_name) = parent;
  704.  
  705.     misc_type_attributes(type_name) = misc_type_attributes(parent);
  706.     l = private_kind(parent);
  707.     if (l != 0) {
  708.         if (misc_type_attributes(type_name) == 0)
  709.             misc_type_attributes(type_name) = l;
  710.         else 
  711.             misc_type_attributes(type_name) = 
  712.               (int) misc_type_attributes(type_name) | l;
  713.     }
  714. }
  715.  
  716. void check_delayed_type(Node node, Symbol type_mark)    /*;check_delayed_type*/
  717. {
  718.     /* called for type and subtype declarations. If the type has a sub-
  719.      * component of a private type, elaboration of the type must be delayed
  720.      * until the private ancestor has been elaborated.
  721.      */
  722.  
  723.     Symbol    pr;
  724.     Node    id_node, decl_node, ancestor_node;
  725.     int        exists;
  726.  
  727.     pr = private_ancestor(type_mark);
  728.     exists = FALSE;
  729.     if (pr != (Symbol)0) exists = TRUE;
  730.     else {
  731.         if (NATURE(type_mark) == na_subtype) {
  732.             pr = TYPE_OF(type_mark);
  733.             if (TYPE_OF(pr) == symbol_incomplete)
  734.                 exists = TRUE;
  735.         }
  736.     }
  737.     if (exists) {
  738.         id_node = N_AST1(node);
  739.         decl_node = copy_node(node);
  740.         N_KIND(node) = as_delayed_type;
  741.         ancestor_node = new_name_node(pr);
  742.         N_AST1(node) = id_node;
  743.         N_AST2(node) = ancestor_node;
  744.         N_AST3(node) = decl_node;
  745.     }
  746. }
  747.  
  748. void subtype_decl(Node node)                                 /*;subtype_decl*/
  749. {
  750.     /* Process  a subtype  declaration. id    is  the     source     id  of     the  new
  751.      * entity, and subt  is the subtype indication. If the subtype indication
  752.      * does not include a constraint, subt is either an anonymous array, or a
  753.      * subtype  indication that fucntions  as a  renaming of  a type. In that
  754.      * case the  new id  denotes the  same entity,    and does  not needs a new
  755.      * symbol table entry,    except that  for conformance  purposes it  is not
  756.      * equivalent to the original type. For now we only introduce  a new sub-
  757.      * type in the case of scalar types.
  758.      */
  759.  
  760.     Node id_node, type_indic_node, constraint;
  761.     char *id;
  762.     Symbol name, subt, parent;
  763.  
  764.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : subtype_decl");
  765.  
  766.     id_node = N_AST1(node);
  767.     type_indic_node = N_AST2(node);
  768.  
  769.     constraint = N_AST2(type_indic_node);
  770.     id = N_VAL(id_node);
  771.     adasem(type_indic_node);
  772.     subt = make_subtype(type_indic_node);
  773.  
  774.     /* The subtype may  be an  array  type which has already  been
  775.      * promoted to anonymous type. It may also be a type_mark without
  776.      * a constraint, i.e. a type name.In this case the new subtype is
  777.      * simply a  renaming of  the type, and     we set     its  unique name
  778.      * to be that type_mark.
  779.      */
  780.  
  781.     /* If the constraint is empty the subtype is simply a renaming. */
  782.     if (constraint == OPT_NODE && (!is_scalar_type(subt)
  783.       || is_generic_type(subt))) {
  784.         N_UNQ(id_node) = subt;
  785.         dcl_put(DECLARED(scope_name), id, subt);
  786.     }
  787.     else {
  788.         current_node = id_node;
  789.         name = find_new(id);
  790.         N_UNQ(id_node) = name;
  791.         SYMBTABcopy(name, subt);
  792.         if (NATURE(subt) == na_enum) {
  793.             /* Do not recopy literal map */
  794.             OVERLOADS(name) = (Set)0;
  795.         }
  796.         NATURE(name) = na_subtype;
  797.         parent = TYPE_OF(name);
  798.         root_type(name) = root_type(parent);
  799.         misc_type_attributes(name) = misc_type_attributes(parent);
  800.         check_delayed_type(node, name);
  801.  
  802.         if (is_generic_type(base_type(parent))) {
  803. #ifdef TBSL
  804.               repr_stmt := ["delayed_repr", {name}];
  805. #endif
  806.         }
  807.         else if (already_forced(base_type(parent))) {
  808.                choose_representation(name);
  809.         }
  810.         else {
  811.                not_chosen_put(base_type(parent), name);
  812.         }
  813.  
  814.     }
  815.     /* Discard the generated anonymous subtype.
  816.      * subt frome NEWTYPES;
  817.      * NEWTYPES with:= [];
  818.      */
  819. }
  820.  
  821. Symbol make_subtype(Node type_indic_node)                      /*;make_subtype*/
  822. {
  823.     Node    name_node, constraint, selector;
  824.     int        nat;
  825.     Symbol    subtype, type_mark, d_type, d_sub;
  826.     Tuple    sigtup;
  827.     char    *type_id;
  828.  
  829.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : make_subtype");
  830.  
  831.     /* Process a subtype indication.*/
  832.  
  833.     name_node = N_AST1(type_indic_node);
  834.     constraint = N_AST2(type_indic_node);
  835.  
  836.     type_mark = find_type(name_node);
  837.  
  838.     if (type_mark== symbol_any) return symbol_any;
  839.  
  840.     /* Retrieve source identifier of type, for test below.*/
  841.     if (N_KIND(name_node) == as_simple_name)
  842.         type_id = N_VAL(name_node);
  843.     else {                    /* extended name */
  844.         selector = N_AST2(name_node);
  845.         type_id = N_VAL(selector);
  846.     }
  847.  
  848.     if (in_open_scopes(base_type(type_mark)) && (! is_task_type(type_mark)
  849.       || strcmp(original_name(type_mark), type_id) == 0) ) {
  850.         /* Component of record is subtype of record type itself, or task type
  851.          * is used within its body.
  852.          */
  853. #ifdef ERRNUM
  854.         str_errmsgn(159, type_id, 160, name_node);
  855. #else
  856.         errmsg_str("invalid use of type % within its definition or body",
  857.           type_id, "3.3, 9.1", name_node);
  858. #endif
  859.         return type_mark;
  860.     }
  861.     else if (constraint == OPT_NODE) {
  862.         current_node = name_node;
  863.         check_incomplete(type_mark);
  864.         return type_mark;
  865.     }
  866.     else {
  867.         /* If the type is a access type, the constraint applies to the type
  868.          * being accessed. We create the corresponding subtype of it, promote
  869.          * it to an anonymous type, and return an access to it.
  870.          */
  871.  
  872.         nat = NATURE(type_mark);
  873.  
  874.         if (is_access(type_mark)) {
  875.             d_type = (Symbol) designated_type(type_mark);
  876.  
  877.             if (NATURE(d_type) == na_array) {
  878.                 d_sub = constrain_array(d_type, constraint);
  879.                 root_type(d_sub) = root_type(d_type);
  880.                 subtype = named_type(strjoin("&", newat_str()));
  881.                 /*Create  a  name for it*/
  882.                 NATURE(subtype) = na_subtype;
  883.                 TYPE_OF(subtype) = type_mark;
  884.                 sigtup = constraint_new(CONSTRAINT_ACCESS);
  885.                 sigtup[2] = (char *) d_sub;
  886.                 SIGNATURE(subtype) = sigtup;
  887.             }
  888.             else if (is_record(d_type) && NATURE(d_type) != na_subtype) {
  889.                 d_sub = constrain_record(d_type, constraint);
  890.                 root_type(d_sub) = root_type(d_type);
  891.                 subtype = named_type(strjoin("&", newat_str()));
  892.                 /*Create  a  name for it*/
  893.                 NATURE(subtype) = na_subtype;
  894.                 TYPE_OF(subtype) = type_mark;
  895.                 sigtup = constraint_new(CONSTRAINT_ACCESS);
  896.                 sigtup[2] = (char *) d_sub;
  897.                 SIGNATURE(subtype) = sigtup;
  898.             }
  899.             else {
  900. #ifdef ERRNUM
  901.                 errmsgn(161, 152, constraint);
  902. #else
  903.                 errmsg("Invalid constraint on access type", "3.8", constraint);
  904. #endif
  905.                 subtype = symbol_any;
  906.             }
  907.         }
  908.  
  909.         else if (nat == na_type) {
  910.             if (is_scalar_type(type_mark))
  911.                 subtype = constrain_scalar(type_mark, constraint);
  912.             else        /* Private type with discriminants, hopefully.*/
  913.                 subtype = constrain_record(type_mark, constraint);
  914.         }
  915.         else if (nat == na_enum)
  916.             subtype = constrain_scalar(type_mark, constraint);
  917.         else if (nat == na_array)
  918.             subtype=constrain_array(type_mark, constraint);
  919.         else if (nat == na_record)
  920.             subtype = constrain_record(type_mark, constraint);
  921.         else if (nat == na_subtype) {
  922.             if (is_array(type_mark) || is_record(type_mark)) {
  923. #ifdef ERRNUM
  924.                 errmsgn(162, 132, type_indic_node);
  925. #else
  926.                 errmsg(
  927.                   "Invalid subtype indication: type is already constrained",
  928.                   "3.6.1, 3.7.2", type_indic_node);
  929. #endif
  930.                 subtype = symbol_any;
  931.             }
  932.             else
  933.                 subtype = constrain_scalar(type_mark, constraint);
  934.         }
  935.         else {
  936. #ifdef ERRNUM
  937.             id_errmsgn(163, type_mark, 164, name_node);
  938. #else
  939.             errmsg_id("Invalid type mark in subtype indication: %",
  940.               type_mark, "3.3, 3.6.1", name_node);
  941. #endif
  942.             subtype = symbol_any;
  943.         }
  944.     }
  945.  
  946.     if (subtype != symbol_any)
  947.         root_type(subtype) = root_type(type_mark);
  948.     else
  949.         N_AST2(type_indic_node) = OPT_NODE;
  950.     return subtype;
  951. }
  952.  
  953. static void derived_type(Symbol derived_subtype,Node def_node) /*;derived_type*/
  954. {
  955.     Node type_indic_node, constraint_node;
  956.     Symbol subtype;
  957.     Symbol parent_subtype, derived_type, parent_type;
  958.     int        nat;
  959.     Tuple     constraint;
  960.  
  961.     if (cdebug2 > 3) TO_ERRFILE("derived type: ");
  962.  
  963.     type_indic_node = N_AST1(def_node);
  964.     adasem(type_indic_node);
  965.     subtype = make_subtype(type_indic_node);
  966.     constraint_node = N_AST2(type_indic_node);
  967.     if (constraint_node == OPT_NODE) {
  968.         parent_subtype = subtype;
  969.         constraint = (Tuple) SIGNATURE(parent_subtype);
  970.         /* Inherited by new type*/
  971.     }
  972.     else {
  973.         /* we use parent_subtype to designate the type mark in the subtype
  974.          * indication. The code below makes sure that the constraint of the
  975.          * parent subtype is also inherited by the derived subtype.
  976.          */
  977.         parent_subtype = TYPE_OF(subtype); /*Subtype indication.*/
  978.         constraint = (Tuple) SIGNATURE(subtype); /* Subtype indication.*/
  979.     }
  980.  
  981.     if (parent_subtype == subtype && (in_unconstrained_natures(NATURE(subtype))
  982.       /*   || (is_generic_type(subtype)) ||is_access(subtype)  */
  983.       ||in_priv_types(TYPE_OF(root_type(subtype))) ))    {
  984.         derived_type = derived_subtype;
  985.     }
  986.     else {
  987.         /* If the derived type definition includes a constraint, or if the
  988.          * old type is constrained, we first derive an anonymous type, and
  989.          * then construct a subtype of it. 
  990.          */
  991.         derived_type = named_type(strjoin(original_name(derived_subtype),
  992.           "\'base"));
  993.         { 
  994.             Tuple tmp = (Tuple) newtypes[tup_size(newtypes)];
  995.             newtypes[tup_size(newtypes)] = 
  996.                 (char *)tup_with(tmp, (char *) derived_type);
  997.  
  998.             NATURE(derived_subtype)    = na_subtype;
  999.             TYPE_OF(derived_subtype)   = derived_type;
  1000.             SIGNATURE(derived_subtype) = (Tuple) constraint;
  1001.             not_chosen_put(derived_type, derived_subtype);
  1002.         }
  1003.     }
  1004.     root_type(derived_type) = derived_type;         /* initially */
  1005.  
  1006.     parent_type = base_type(parent_subtype);
  1007.     nat = NATURE(SCOPE_OF(parent_type));
  1008.     /* A derived type defined in a prackage specification cannot be used for
  1009.      * further derivation until the end of its visible part. 
  1010.      */
  1011.     if (is_derived_type(parent_type) && (in_open_scopes(parent_type)
  1012.       && (nat == na_package_spec || nat == na_generic_package_spec))
  1013.       ||  TYPE_OF(parent_type) == symbol_incomplete
  1014.       || private_ancestor(parent_type) != (Symbol)0 ) {
  1015. #ifdef ERRNUM
  1016.         id_errmsgn(165, parent_type, 166, type_indic_node);
  1017. #else
  1018.         errmsg_id("premature derivation of derived or private type %",
  1019.           parent_type, "3.4, 7.4.1", type_indic_node);
  1020. #endif
  1021.     }
  1022.     build_derived_type(parent_subtype, derived_type , type_indic_node);
  1023. }
  1024.  
  1025. static void build_derived_type(Symbol parent_subtype, Symbol derived_type,
  1026.   Node node)                                        /*;build_derived_type */ 
  1027. {
  1028.     /* build symbol table entry for derived type, after processing constraint.
  1029.      * called from previous procedure, and from update_one_entry, to handle
  1030.      * types derived from generic formal types.
  1031.      */
  1032.  
  1033.     Symbol parent_type, parent_scope;
  1034.     Symbol comp;
  1035.     int    exists, nat1, i, l;
  1036.     Forset    fs;
  1037.     Symbol new_lit_name, lit_sym, nam;
  1038.     Symbol    d1, d2;
  1039.     char    *lit_id;
  1040.     Tuple new_sig, lit_map, dl1, dl2, array_info;
  1041.     Declaredmap    parent_dcl;
  1042.  
  1043.     parent_type = base_type(parent_subtype);
  1044.     nat1 = NATURE(parent_type);
  1045.  
  1046.     switch (nat1 = NATURE(parent_type)) {
  1047.     case na_type:
  1048.         NATURE(derived_type)    = na_type;
  1049.         TYPE_OF(derived_type)   = parent_type;
  1050.         SIGNATURE(derived_type) = SIGNATURE(parent_type);
  1051.         break;
  1052.     case na_array:
  1053.         array_info = SIGNATURE(parent_type);
  1054.         /* The following code is very similar to new_unconstrained_array but
  1055.          * avoids building a tree fragment for the array and then unpacking it
  1056.          */
  1057.         comp = (Symbol) array_info[2];
  1058.         NATURE(derived_type)    = na_array;
  1059.         TYPE_OF(derived_type)   = derived_type;
  1060.         SIGNATURE(derived_type) = array_info;
  1061.         /* Mark the type as limited if the component type is.*/
  1062.         misc_type_attributes(derived_type) = private_kind(comp);
  1063.         /* For each unconstrained array type, we introduce an instance of the
  1064.          * 'aggregate' pseudo-operator for that array.
  1065.          */
  1066.         new_agg_or_access_agg(derived_type);
  1067.         break;
  1068.  
  1069.     /* A derived record type has the same fields and types as the parent.
  1070.      * All we need to do is introduce an aggregate under the new type mark.
  1071.      * The declaration may have a discriminant part, in which case they
  1072.      * must conform to the discriminants of the parent type. We assume that
  1073.      * the discriminant names, types, and default values must be the same.
  1074.      */
  1075.     case na_record:
  1076.         if (is_record(derived_type)) {
  1077.             dl1 = (Tuple) discriminant_list(derived_type);
  1078.             dl2 = (Tuple) discriminant_list(parent_type);
  1079.             exists = FALSE;
  1080.             if (tup_size(dl1) != tup_size(dl2)) {
  1081.                 exists = TRUE;
  1082.                 if (! exists) {
  1083.                     for (i = 1; i <= tup_size(dl1); i++) {
  1084.                         d1 = (Symbol) dl1[i]; 
  1085.                         d2 = (Symbol) dl2[i];
  1086.                         if (TYPE_OF(d1) != TYPE_OF(d2)
  1087.                              || default_expr(d1) != default_expr(d2) /*$tree equ?*/
  1088.                           || strcmp(original_name(d1),original_name(d2)) != 0) {
  1089.                             exists = TRUE;
  1090.                             break;
  1091.                         }
  1092.                     }
  1093.                 }
  1094.                 if (exists) {
  1095. #ifdef ERRNUM
  1096.                     /* translation to errmsgn below incorrect, so use full text
  1097.                        errmsgn(167, 152, type_indic_node);
  1098.                      */
  1099.                     errmsg("discriminant mismatch in derived type declaration",
  1100.                       "3.8", node);
  1101. #else
  1102.                     errmsg("discriminant mismatch in derived type declaration",
  1103.                       "3.8", node);
  1104. #endif
  1105.                 }
  1106.             }
  1107.         }
  1108.         NATURE(derived_type) = na_record;
  1109.         TYPE_OF(derived_type) = derived_type;
  1110. #ifdef TBSL
  1111.         -- is it necessary to 'copy' SIGNATURE and/or DECLARED. 
  1112.            -- check this. For now, do copy for DECLARED    ds 6-jan-85
  1113. #endif
  1114.         SIGNATURE(derived_type) = record_declarations(parent_type);
  1115.         DECLARED(derived_type) = DECLARED(parent_type);
  1116.         if (DECLARED(parent_type) != (Declaredmap) 0)
  1117.             DECLARED(derived_type) = dcl_copy(DECLARED(parent_type));
  1118.         new_agg_or_access_agg(derived_type);
  1119.         break;
  1120.     /* A derived enumeration type has the literals of its parent, but these
  1121.         * are marked as derived, to enforce the overloading rules.
  1122.         */
  1123.     case na_enum:
  1124.         lit_map = (Tuple) literal_map(parent_type);
  1125.         parent_scope = SCOPE_OF(parent_type);
  1126.         parent_dcl = DECLARED(parent_scope);
  1127.         /* Recall that literal map as tuple for now */
  1128.         for (i = 1; i <= tup_size(lit_map); i+=2) {
  1129.             lit_id = lit_map[i];
  1130.             /* retrieve unique_name of literal */
  1131.             lit_sym = dcl_get(parent_dcl, lit_id);
  1132.             FORSET(nam=(Symbol), OVERLOADS(lit_sym), fs)
  1133.                 if (TYPE_OF(nam) == parent_type)
  1134.                     break;
  1135.             ENDFORSET(fs)
  1136.             new_lit_name =
  1137.               chain_overloads(lit_id, na_literal, derived_type,
  1138.               tup_new(0), nam, OPT_NODE);
  1139.             ALIAS(new_lit_name) = nam; /* unique name of parent */
  1140.         }
  1141.         new_sig = SIGNATURE(parent_type);
  1142.         NATURE(derived_type)    = na_enum;
  1143.         TYPE_OF(derived_type)   = derived_type;
  1144.         SIGNATURE(derived_type) = new_sig;
  1145.         OVERLOADS(derived_type) = (Set) lit_map;
  1146.         break;
  1147.     case na_access:
  1148.         NATURE(derived_type)    = na_access;
  1149.         TYPE_OF(derived_type)   = derived_type;
  1150.         SIGNATURE(derived_type) = SIGNATURE(parent_type);
  1151.         new_agg_or_access_acc(derived_type);
  1152.         break;
  1153.     case na_task_type:
  1154.     case na_task_type_spec:
  1155.         SYMBTABcopy(derived_type, parent_type);
  1156.         NATURE(derived_type)   = na_task_type; /*even if parent is spec*/
  1157.         DECLARED(derived_type) = DECLARED(parent_type);
  1158.         break;
  1159.     default:    /*previous error, unsupported numeric type, etc. */
  1160.         break;
  1161.     }
  1162.  
  1163.     root_type(derived_type) = root_type(parent_type);
  1164.  
  1165.     derive_subprograms(parent_subtype, derived_type);
  1166.     if (nat1 != na_enum) {
  1167.         l = private_kind(parent_type);
  1168.         misc_type_attributes(derived_type) = l;
  1169.         /* otherwise the attribute is the literal map*/
  1170.     }
  1171. inherit_representation_info(derived_type, parent_type);
  1172. }
  1173.  
  1174. static int in_unconstrained_natures(int x)        /*;in_unconstrained_natures*/
  1175. {
  1176.     /* equiv to x in unconstrained_natures ... */
  1177.     return x == na_enum || x == na_array || x == na_record || x == na_access
  1178.       || x == na_task_type || x == na_task_type_spec;
  1179. }
  1180.  
  1181. static int is_derived_type(Symbol mark)  /*;is_derived_type*/
  1182. {
  1183.     return (base_type(mark) != root_type(mark) && (! is_generic_type(mark)));
  1184.  
  1185.     /* Incomplete for composite types.*/
  1186. }
  1187.  
  1188. static void derive_subprograms(Symbol parent_subtype, Symbol derived_type)
  1189.                                                         /*;derive_subprograms*/
  1190. {
  1191.     /* In order to derive the subprograms of the parent type, the parent type
  1192.      * must be defined in  the visible part of a package, and the derivation
  1193.      * must take place after the end of this visible part.
  1194.      *
  1195.      * We introduce in the symbol table the new subprograms with the derived
  1196.      * signature, but do not emit code for them. We produce instead a
  1197.      * mapping from the inherited subprogram to its ancestor, and replace
  1198.      * the name at the point of call, in macro-like fashion.
  1199.      *
  1200.      * If the  parent type is a private type whose full declaration is
  1201.      * a first-named subtype, then  its base type is declared in the private
  1202.      * part. Then if the derivation takes place in the private part itself,
  1203.      * the parent type does not appear in the visible part of the package,
  1204.      * but the parent subtype does. This anomaly must be checked for explicitly.
  1205.      * checked for separately.
  1206.      */
  1207.  
  1208.     Symbol    parent_scope, sym, obj;
  1209.     Symbol  parent_type;
  1210.     int    is_visible_type, nat;
  1211.     char    *str, *id;
  1212.     Fordeclared    div;
  1213.     Declaredmap decmap;
  1214.  
  1215.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : derive_subprograms");
  1216.  
  1217.     parent_type  = base_type(parent_subtype);
  1218.     parent_scope = SCOPE_OF(parent_type);
  1219.     nat          = NATURE(parent_scope);
  1220.     is_visible_type = FALSE;
  1221.     decmap = (Declaredmap)(DECLARED(parent_scope));
  1222.  
  1223.     if ((nat == na_package || nat == na_package_spec)
  1224.       && !in_open_scopes(parent_scope)) {
  1225.         /* common case: derivation outside of package.*/
  1226.         FORVISIBLE(str, sym, decmap, div)
  1227.             if (sym == parent_type) {
  1228.                 is_visible_type = TRUE;
  1229.                 break;
  1230.             }
  1231.         ENDFORVISIBLE(div)
  1232.     }
  1233.     else if (nat == na_private_part
  1234.       /* which is a currently open scope. */
  1235.       || (nat == na_package && in_open_scopes(parent_scope))) {
  1236.         /* verify that parent SUBtype is declared in visible part. */
  1237.         FORVISIBLE(str, sym, decmap, div)
  1238.             if (sym == parent_subtype) {
  1239.                 is_visible_type = TRUE;
  1240.                 break;
  1241.             }
  1242.         ENDFORVISIBLE(div)
  1243.     }
  1244.     if (is_visible_type) {    /* calculate inheritance.*/
  1245.         if (parent_scope == scope_name) {
  1246.             /* Derivation is in private part of package that declares the
  1247.              * parent. Copy declared map to insure that domain of iteration of
  1248.              * following loop is not modified by insertions of derived
  1249.              * subprograms.
  1250.              */
  1251.             decmap = dcl_copy(decmap);
  1252.         }
  1253.         FORVISIBLE(id, obj, decmap, div)
  1254.             nat = NATURE(obj);
  1255.             if((nat == na_procedure || nat == na_procedure_spec
  1256.               || nat == na_function  || nat == na_function_spec)
  1257.               && !is_derived_subprogram(obj))
  1258.                 derive1_subprogram(obj, parent_type, derived_type, obj);
  1259.         ENDFORVISIBLE(div)
  1260.     }
  1261.     if (is_derived_type(parent_type) && parent_scope != symbol_standard0) {
  1262.         /* If the original type is a derived type, its derived subprograms
  1263.          * are further derived. If such exist, they are aliased subprograms
  1264.          * declared in the same scope as the parent type.
  1265.          */
  1266.         if ( !is_visible_type && parent_scope == scope_name)
  1267.             decmap = dcl_copy(decmap);
  1268.  
  1269.         FORDECLARED(id, obj, decmap, div)
  1270.             nat = NATURE(obj);
  1271.             if ((nat == na_procedure || nat == na_procedure_spec
  1272.               || nat == na_function || nat == na_function_spec)
  1273.               && is_derived_subprogram(obj)
  1274.               && ( ! is_visible_type || ! hidden_derived(obj, parent_scope) ))
  1275.                 derive1_subprogram(obj, parent_type, derived_type, ALIAS(obj));
  1276.         ENDFORDECLARED(div)
  1277.     }
  1278. }
  1279.  
  1280. static void derive1_subprogram(Symbol obj, Symbol parent_type,
  1281.   Symbol derived_type, Symbol parent_subp)                /*;derive1_subprogram*/
  1282. {
  1283.     /* obj is a subprogram declared in the same scope as parent_type. If
  1284.      * some type in its profile is compatible with parent_type, produce
  1285.      * a derived subprogram by replacing the parent_type with the derived
  1286.      * one, and introduce a subprogram declaration with this new profile.
  1287.      * The parent subprogram is either obj itself, or ALIAS(obj) if obj is
  1288.      * already a derived subprogram.
  1289.      */
  1290.     Symbol    new_typ, formal, tf, dx, new_proc;
  1291.     Symbol neq, new_neq;
  1292.     char    *id;
  1293.     int    is_new, nat;
  1294.     Fortup    ft1;
  1295.     Tuple    new_sig, t;
  1296.  
  1297.     new_sig = tup_new(0);
  1298.     new_typ = TYPE_OF(obj);
  1299.     is_new = FALSE;
  1300.  
  1301.     FORTUP(formal =(Symbol) , SIGNATURE(obj), ft1);
  1302.         nat = NATURE(formal);
  1303.         id = original_name(formal);
  1304.         tf = TYPE_OF(formal);
  1305.         dx = (Symbol) default_expr(formal);
  1306.  
  1307.         if (compatible_types(tf, parent_type)) {
  1308.             tf = derived_type;
  1309.             is_new = TRUE;
  1310.         }
  1311.         t = tup_new(4);
  1312.         t[1] =  strjoin(id, "");
  1313.         t[2] = (char *) nat;
  1314.         t[3] = (char *) tf;
  1315.         t[4] = (char *) dx;
  1316.         new_sig = tup_with(new_sig, (char *) t);
  1317.     ENDFORTUP(ft1);
  1318.  
  1319.     if (compatible_types(new_typ, parent_type) ) {
  1320.         new_typ = derived_type;
  1321.         is_new  = TRUE;
  1322.     }
  1323.  
  1324.     if (is_new) {
  1325.         /* subprogram is derived. Insert it in current scope, with
  1326.          * the new signature, and recall its lineage.
  1327.          * Its nature is a subprogram, not a spec, because no body
  1328.          * will be defined for it.
  1329.          */
  1330.         nat = NATURE(obj) == na_procedure_spec ? na_procedure : na_function;
  1331.         id = original_name(obj);
  1332.  
  1333.         /* If the subprogram is /=, it will be automatically derived when
  1334.          * te corresponding equality operator is.
  1335.          */
  1336.         if (streq(id, "/=")) return;
  1337.         /*new_proc = chain_overloads(id, [nat,new_typ, new_sig, parent_subp]);*/
  1338.         new_proc = chain_overloads(id, nat, new_typ, new_sig, parent_subp,
  1339.           OPT_NODE);
  1340.         if (new_proc != (Symbol)0) { /* There is no explicit sub-*/
  1341.             ALIAS(new_proc) = parent_subp;       /* program with that name.*/
  1342.             if (streq(id, "=")) {
  1343.                 /* mark the parent of the corresponding inequality. */
  1344.                 neq            = find_neq(parent_subp);
  1345.                 new_neq        = find_neq(new_proc);
  1346.                 ALIAS(new_neq) = neq;
  1347.             }
  1348.         }
  1349.     }
  1350. }
  1351.  
  1352. static int hidden_derived(Symbol subp, Symbol parent_scope)    /*;hidden_derived */
  1353. {
  1354.     /* Determine whether a derived subprogram is hidden by an explicit 
  1355.      * declaration in the visible part of a package.
  1356.      * If the derivation occurs within the private part of the package,  or
  1357.      * within its body, the set of subprograms that may hide the derived one is
  1358.      * the overloads set of the private declarations of the symbol. Otherwise
  1359.      * it is  the overloads set of the visible symbol.
  1360.      */
  1361.  
  1362.     Symbol seen, s;
  1363.     Forset fs1;
  1364.     Symbol obj;
  1365.  
  1366.     seen = dcl_get_vis(DECLARED(parent_scope), ORIG_NAME(subp));
  1367.  
  1368.     if (seen == (Symbol)0) return FALSE;
  1369.  
  1370.     else if ( in_open_scopes(parent_scope)
  1371.       && NATURE(parent_scope) != na_package_spec 
  1372.       && (s = private_decls_get((Private_declarations)
  1373.       private_decls(parent_scope), seen)) != (Symbol)0 )
  1374.         seen = s;
  1375.  
  1376.     if (!can_overload(seen)) return FALSE;
  1377.  
  1378.     FORSET(obj=(Symbol), OVERLOADS(seen), fs1)
  1379.         if ( obj != subp && same_signature(obj, subp)
  1380.           && base_type(TYPE_OF(subp)) == base_type(TYPE_OF(obj)))
  1381.             return TRUE;
  1382.     ENDFORSET(fs1);
  1383.     return FALSE;
  1384. }
  1385.  
  1386. static Symbol find_neq(Symbol eq_name)                            /*;find_new*/
  1387. {
  1388.     /* find implicitly defined inequality corresponding to an equality operator,
  1389.      * either explicitly defined or derived, by iterating over definitions of /=
  1390.      * in the scope, that have the same signature as the given equality.
  1391.      */
  1392.  
  1393.     Forset fs1;
  1394.     Symbol neq;
  1395.  
  1396.     FORSET(neq=(Symbol), OVERLOADS(dcl_get(DECLARED(SCOPE_OF(eq_name)), "/=")),
  1397.       fs1)
  1398.         if (same_signature(neq, eq_name)) {
  1399.         return neq;
  1400.     }
  1401.     ENDFORSET(fs1)
  1402.     chaos("can't find inequality operator in scope");
  1403.     return (Symbol)0;
  1404. }
  1405.  
  1406. int is_derived_subprogram(Symbol name)                 /*;is_derived_subprogram*/
  1407. {
  1408.     Symbol s;
  1409.  
  1410.     s = ALIAS(name);
  1411.     return (s != (Symbol)0 && streq(ORIG_NAME(s) , ORIG_NAME(name)) );
  1412. }
  1413.  
  1414. static void new_enum_type(Symbol type_name, Node def_node)  /*;new_enum_type*/
  1415. {
  1416.     Tuple c;
  1417.     Tuple    lit_map, literals_list;
  1418.     int    i;
  1419.     Node    lo, hi, tmpnode;
  1420.  
  1421.     adasem(def_node);
  1422.     literals_list = N_LIST(def_node);
  1423.     lit_map = tup_new(2*tup_size(literals_list));
  1424.  
  1425.     for (i = 1; i <= tup_size(literals_list); i++) {
  1426.         /* insert each literal in symbol table, as an overloadable identifier
  1427.          * Each enumeration type is mapped  into a sequence    of integers, and
  1428.          * each literal is defined as a constant with integer value.
  1429.          */
  1430.         tmpnode = (Node)(literals_list[i]);
  1431.         chain_overloads(N_VAL(tmpnode), na_literal, type_name, tup_new(0),
  1432.           (Symbol)0, OPT_NODE);
  1433.         /*    lit_map(N_VAL(literals_list(i))) := i-1;*/
  1434.         /*    lit_map[2*i-1] = (char *) N_VAL((Node)(literals_list[i]));*/
  1435.         lit_map[2*i-1] = N_VAL(tmpnode);
  1436.         lit_map[2*i] = (char *) i-1;
  1437.     }
  1438.     lo = new_ivalue_node(int_const(0), type_name);
  1439.     hi = new_ivalue_node(int_const(tup_size(literals_list) - 1), type_name);
  1440. #ifdef TBSN
  1441.     -- this should no longer be necessary, as they are saved in
  1442.     -- collect_unit_nodes
  1443.     /* Attach nodes of bounds to AST, to insure saving for separate 
  1444.      * compilation.
  1445.      */
  1446.     /*N_LIST(def_node) +:= [lo, hi];*/
  1447.     N_LIST(def_node) = tup_with(N_LIST(def_node), (char *) lo);
  1448.     N_LIST(def_node) = tup_with(N_LIST(def_node), (char *) hi);
  1449. #endif
  1450.     /*SYMBTAB(type_name) := [na_enum, type_name, ['range', lo, hi], lit_map];*/
  1451.     NATURE(type_name) = na_enum;
  1452.     TYPE_OF(type_name) = type_name;
  1453.     c = constraint_new(CONSTRAINT_RANGE);
  1454.     numeric_constraint_low(c) = (char *) lo;
  1455.     numeric_constraint_high(c) = (char *) hi;
  1456.     SIGNATURE(type_name) = (Tuple) c;
  1457.     OVERLOADS(type_name) = (Set) lit_map;
  1458.     initialize_representation_info(type_name, TAG_ENUM);
  1459. }
  1460.  
  1461. static void new_integer_type(Symbol type_name, Node def_node)
  1462.                                                         /*;new_integer_type*/
  1463. {
  1464.     /* Create a new integer, and apply the constraint to obtain subtype of it.*/
  1465.  
  1466.     Symbol    newtype;
  1467.     Node constraint_node, lo, hi;
  1468.     Tuple    c;
  1469.  
  1470.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : new_integer_type");
  1471.  
  1472.     constraint_node = N_AST1(def_node);
  1473.     adasem(constraint_node);
  1474.  
  1475.     newtype = anonymous_type();
  1476.     SYMBTABcopy(newtype, symbol_integer);
  1477.     root_type(newtype) = symbol_integer;
  1478.     inherit_representation_info(newtype, symbol_integer);
  1479.  
  1480.     /* get bounds of range : lo, hi.*/
  1481.     lo = N_AST1(constraint_node);
  1482.     hi = N_AST2(constraint_node);
  1483.  
  1484.     check_type_i(lo);
  1485.     check_type_i(hi);
  1486.     specialize(lo, symbol_integer);
  1487.     specialize(hi, symbol_integer);
  1488.  
  1489.     if (!(is_static_expr(lo)) || (! (is_static_expr(hi)))) {
  1490. #ifdef ERRNUM
  1491.         errmsgn(170, 171, constraint_node);
  1492. #else
  1493.         errmsg("Bounds in an integer type definition must be static",
  1494.           "3.5.4", constraint_node);
  1495. #endif
  1496.     }
  1497.     else if (root_type(N_TYPE(lo)) != symbol_integer
  1498.       || root_type(N_TYPE(hi)) != symbol_integer)     {
  1499.         /* these are tests on the root type of each node.*/
  1500. #ifdef ERRNUM
  1501.         l_errmsgn(172, 173, 171, constraint_node);
  1502. #else
  1503.         errmsg_l("Bounds in an integer type definition must be of some ",
  1504.           "integer type", "3.5.4", constraint_node);
  1505. #endif
  1506.     }
  1507.     NATURE(type_name) = na_subtype;
  1508.     TYPE_OF(type_name) = newtype;
  1509.     c = constraint_new(CONSTRAINT_RANGE);
  1510.     numeric_constraint_low(c) = (char *) lo;
  1511.     numeric_constraint_high(c) = (char *) hi;
  1512.     SIGNATURE(type_name) = (Tuple) c;
  1513.     not_chosen_put(newtype, type_name);
  1514. }
  1515.  
  1516. static void new_floating_type(Symbol type_name, Node def_node)
  1517.                                                         /*;new_floating_type*/
  1518. {
  1519.     Node    float_pt_node, precision_node, opt_range, lo, hi;
  1520.     Symbol    newtype, p_type;
  1521.     Symbol    anonymous_type();
  1522.     int    digits;
  1523.     Tuple constraint;
  1524.     Const    con;
  1525.  
  1526.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : new_floating_type");
  1527.  
  1528.     /* Process a floating point declaration.*/
  1529.     float_pt_node = N_AST1(def_node);
  1530.     adasem(float_pt_node);
  1531.  
  1532.     precision_node = N_AST1(float_pt_node);
  1533.     opt_range = N_AST2(float_pt_node);
  1534.  
  1535.     /* The range constraint is optional. If absent, the range is that of
  1536.      * the parent type. If present,     the bounds  need not be of the same
  1537.      * type, but of some real type, and static. Their resolution is done
  1538.      * in procedure real-bound.
  1539.      */
  1540.  
  1541.     newtype = anonymous_type();
  1542.     SYMBTABcopy(newtype, symbol_float);
  1543.     root_type(newtype) = symbol_float;
  1544.     SYMBTABcopy(type_name, newtype);       /* by default.*/
  1545.     check_type_i(precision_node);
  1546.     p_type = N_TYPE(precision_node);
  1547.  
  1548.     if (p_type == symbol_any)  /* Type error.*/
  1549.         return;
  1550.     else if (! is_static_expr(precision_node)) {
  1551. #ifdef ERRNUM
  1552.         errmsgn(174, 175, precision_node);
  1553. #else
  1554.         errmsg("Expect static expression for digits", "3.5.7", precision_node);
  1555. #endif
  1556.         return;
  1557.     }
  1558.  
  1559.     if (p_type == symbol_universal_integer)
  1560.         specialize(precision_node, symbol_integer);
  1561.     else if (root_type(p_type) != symbol_integer) {
  1562. #ifdef ERRNUM
  1563.         errmsgn(176, 175, precision_node);
  1564. #else
  1565.         errmsg("Expect integer expression for DIGITS", "3.5.7", precision_node);
  1566. #endif
  1567.         return;
  1568.     }
  1569.  
  1570.     eval_static(precision_node);
  1571.     con = (Const) N_VAL(precision_node);
  1572.     digits = con->const_value.const_int;
  1573.     if (digits < 1) {
  1574. #ifdef ERRNUM
  1575.         errmsgn(177, 175, precision_node);
  1576. #else
  1577.         errmsg("Invalid digits value in real type declaration", "3.5.7",
  1578.           precision_node);
  1579. #endif
  1580.         return;
  1581.     }
  1582.     else if (digits > ADA_REAL_DIGITS) {
  1583. #ifdef ERRNUM
  1584.         errmsgn(178, 10, precision_node);
  1585. #else
  1586.         errmsg("Precision not supported by implementation", "none",
  1587.           precision_node);
  1588. #endif
  1589.         return;
  1590.     }
  1591.  
  1592.     inherit_representation_info(newtype, symbol_float);
  1593.     if (opt_range == OPT_NODE) {        /* Use system FLOAT.*/
  1594.         /* constraint = SIGNATURE(symbol_float);
  1595.          * constraint(4) = precision_node;    
  1596.          */
  1597.         Tuple sig = (Tuple) SIGNATURE(symbol_float);
  1598.         constraint = constraint_new(CONSTRAINT_DIGITS);
  1599.         numeric_constraint_low(constraint) = numeric_constraint_low(sig);
  1600.         numeric_constraint_high(constraint) = numeric_constraint_high(sig);
  1601.         numeric_constraint_digits(constraint) = (char *) precision_node;
  1602.     }
  1603.     else {
  1604.         lo = N_AST1(opt_range);
  1605.         hi = N_AST2(opt_range);
  1606.  
  1607.         if (real_bound(lo, symbol_float) == OPT_NODE) return;
  1608.         if (real_bound(hi, symbol_float) == OPT_NODE) return;
  1609.  
  1610.         constraint = constraint_new(CONSTRAINT_DIGITS);
  1611.         numeric_constraint_low(constraint) = (char *) lo;
  1612.         numeric_constraint_high(constraint) = (char *) hi;
  1613.         numeric_constraint_digits(constraint) = (char *) precision_node;
  1614.     }
  1615.  
  1616.     NATURE(type_name) = na_subtype;
  1617.     TYPE_OF(type_name) = newtype;
  1618.     SIGNATURE(type_name) = (Tuple) constraint;
  1619.     not_chosen_put(newtype, type_name);
  1620. }
  1621.  
  1622. static void new_fixed_type(Symbol type_name, Node def_node)  /*;new_fixed_type*/
  1623. {
  1624.     Node    lo, hi, fixed_pt_node, precision_node, opt_range, small_node;
  1625.     Symbol    r, p_type, anon_type;
  1626.     Tuple constraint;
  1627.     Rational small_val;
  1628.     Rational lo_val, hi_val, anon_lo_val, anon_hi_val;
  1629.     int    power_conv;
  1630.  
  1631.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : new_fixed_type");
  1632.  
  1633.     /* Process a fixed point declaration. Similar to floating case.*/
  1634.  
  1635.     fixed_pt_node = N_AST1(def_node);
  1636.     adasem(fixed_pt_node);
  1637.  
  1638.     precision_node = N_AST1(fixed_pt_node);
  1639.     opt_range = N_AST2(fixed_pt_node);
  1640.  
  1641.     anon_type = anonymous_type();
  1642.     NATURE(anon_type)  = na_type;
  1643.     TYPE_OF(anon_type) = anon_type;
  1644.     root_type(anon_type) = symbol_dfixed;
  1645.  
  1646.     NATURE(type_name)    = na_subtype;
  1647.     TYPE_OF(type_name)   = anon_type;
  1648. #ifdef TBSL
  1649.     -- see if tup_copy needed for SIGNATURE assignments below
  1650.         ds 6-jan-85
  1651. #endif
  1652.     SIGNATURE(anon_type) = SIGNATURE(symbol_dfixed);
  1653.     SIGNATURE(type_name) = SIGNATURE(symbol_dfixed);
  1654.  
  1655.     initialize_representation_info(anon_type, TAG_FIXED);
  1656.     not_chosen_put(anon_type, type_name);
  1657.     check_type_r(precision_node);
  1658.     p_type = N_TYPE(precision_node);
  1659.  
  1660.     if (N_TYPE(precision_node) == symbol_any)  /* Type error.*/
  1661.         return;
  1662.     else if (! is_static_expr(precision_node)) {
  1663. #ifdef ERRNUM
  1664.         errmsgn(179, 175, precision_node);
  1665. #else
  1666.         errmsg("Expect static expression for delta", "3.5.7", precision_node);
  1667. #endif
  1668.         return;
  1669.     }
  1670.  
  1671.     r = root_type(p_type);
  1672.     if (is_fixed_type(r) || r == symbol_universal_real);
  1673.     else if (r == symbol_float)
  1674.         N_VAL(precision_node) = (char *) rat_const(rat_frr
  1675.           (REALV((Const)N_VAL(precision_node))));
  1676.     else {
  1677. #ifdef ERRNUM
  1678.         errmsgn(180, 181, precision_node);
  1679. #else
  1680.         errmsg("Expression for delta must be of some real type", "3.5.9",
  1681.           precision_node);
  1682. #endif
  1683.         return;
  1684.     }
  1685.  
  1686.     if (opt_range == OPT_NODE) {
  1687. #ifdef ERRNUM
  1688.         errmsgn(182, 181, fixed_pt_node);
  1689. #else
  1690.         errmsg("Missing range in Fixed type declaration", "3.5.9",
  1691.           fixed_pt_node);
  1692. #endif
  1693.         return;
  1694.     }
  1695.     else {
  1696.         lo = N_AST1(opt_range);
  1697.         hi = N_AST2(opt_range);
  1698.         if (real_bound(lo, symbol_dfixed) == OPT_NODE)return;
  1699.         if (real_bound(hi, symbol_dfixed) == OPT_NODE) return;
  1700.  
  1701.         N_TYPE(lo) = N_TYPE(hi) = anon_type;
  1702.  
  1703.         lo_val = RATV((Const)N_VAL(lo));
  1704.         hi_val = RATV((Const)N_VAL(hi));
  1705.         /* The constraint may eventually carry a rep.spec. for 'SMALL. Its
  1706.          * absence is marked by OPT_NODE.
  1707.          */
  1708.         /*constraint := ['delta', lo, hi, precision_node, OPT_NODE];*/
  1709.         constraint = constraint_new(CONSTRAINT_DELTA);
  1710.         numeric_constraint_low(constraint)   = (char *) lo;
  1711.         numeric_constraint_high(constraint)  = (char *) hi;
  1712.         numeric_constraint_delta(constraint) = (char *) precision_node;
  1713.         numeric_constraint_small(constraint) = (char *) OPT_NODE;
  1714.         power_conv = power_of_2((Const) N_VAL(precision_node));
  1715.         small_val = power_of_2_small;
  1716.         if (power_conv) { /* if cannot convert */
  1717.             errmsg("Precision not supported by implementation.",
  1718.               "Appendix F", fixed_pt_node);
  1719.         }
  1720.         else {
  1721.             small_node = new_ivalue_node(rat_const(small_val),
  1722.               get_type(precision_node));
  1723.             numeric_constraint_small(constraint) = (char *) small_node;
  1724.         }
  1725.     }
  1726.     SIGNATURE(type_name) = (Tuple) constraint;
  1727.     /* compute signature for anonymous type */
  1728.     constraint = tup_copy(constraint);
  1729.     /* now compute proper lower and upper bounds for anonymous type */
  1730.     /* N_VAL(l_node) := [(MIN_INT+1)*num(small), den(small)]; */
  1731.     anon_lo_val = rat_fri(int_mul(int_add(ADA_MIN_FIXED_MP, int_fri(1)),
  1732.       num(small_val)), den(small_val));
  1733.  
  1734.     /* N_VAL(u_node) := [MAX_INT*num(small), den(small)]; */
  1735.     anon_hi_val = rat_fri( int_mul(ADA_MAX_FIXED_MP,
  1736.       num(small_val)), den(small_val));
  1737.  
  1738.     numeric_constraint_low(constraint)  = 
  1739.       (char *)new_ivalue_node(rat_const(anon_lo_val), type_name);
  1740.  
  1741.     numeric_constraint_high(constraint) = 
  1742.       (char *)new_ivalue_node(rat_const(anon_hi_val), type_name);
  1743.  
  1744.     SIGNATURE(anon_type) = (Tuple) constraint;
  1745.  
  1746.     if (rat_geq(anon_hi_val, hi_val));   /* type is representable */
  1747.     else if (rat_eql(rat_sub(hi_val, anon_hi_val), small_val))
  1748.         /* given bound is 'small away from model number. Set 'last of the type
  1749.          * to be largest model number.
  1750.          */
  1751.         N_VAL(hi) = (char *)rat_const(anon_hi_val);
  1752.     else errmsg("fixed type definition requires more than MAX_MANTISSA bits",
  1753.       "Appendix F", fixed_pt_node);
  1754.  
  1755.     if (rat_leq(anon_lo_val, lo_val));
  1756.     else if (rat_eql(rat_sub(anon_lo_val, lo_val), small_val))
  1757.         /* Set 'first of the type to be smallest model number.  */
  1758.         N_VAL(lo) = (char *)rat_const(anon_lo_val);
  1759.     else errmsg("fixed type definition requires more than MAX_MANTISSA bits",
  1760.       "Appendix F", fixed_pt_node);
  1761. }
  1762.  
  1763. static Node real_bound(Node bound, Symbol kind)                  /*;real_bound*/
  1764. {
  1765.     /* Verify that the bound of a range constraint in a real type definition
  1766.      * is a real type, and convert it to or from universal when needed.
  1767.      */
  1768.  
  1769.     Symbol    b_type, r_type;
  1770.  
  1771.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : real_bound");
  1772.  
  1773.     check_type_r(bound);
  1774.     b_type = N_TYPE(bound);
  1775. /*// Is following return value correct? Added to get code to compile with CC*/
  1776.     if (b_type == symbol_any) return OPT_NODE;
  1777.     r_type = root_type(b_type);
  1778.  
  1779.     if (! is_static_expr(bound)) {
  1780. #ifdef ERRNUM
  1781.         errmsgn(183, 184, bound);
  1782. #else
  1783.         errmsg("Bound in range constraint of type definition must be static",
  1784.           "3.5.7, 3.5.9", bound);
  1785. #endif
  1786.         return OPT_NODE;
  1787.     }
  1788.     else if (kind == symbol_float)  /* Fixed or universal bound.*/
  1789.         specialize(bound, symbol_float);
  1790.     else if (is_fixed_type(kind)) {
  1791.         if (r_type == symbol_float) {
  1792.             N_VAL(bound) =
  1793.               (char *) rat_const(rat_frr(REALV((Const)N_VAL(bound))));
  1794.             N_TYPE(bound) = symbol_dfixed;
  1795.         }
  1796.     }
  1797.     return bound;
  1798. }
  1799.  
  1800. static Symbol constrain_scalar(Symbol type_mark, Node constraint)
  1801.                                                         /*;constrain_scalar*/
  1802. {
  1803.     /* Constrain a discrete type or a real type */
  1804.  
  1805.     int constr;
  1806.     Symbol    base_mark, bt, kind;
  1807.     Node lo, hi, precision, range_constraint, attr_node, base_precision;
  1808.     int constr_type, digits;
  1809.     Tuple new_c, old_c;
  1810.     Symbol    typ;
  1811.     Const    delta;
  1812.     Rational    rdelta;
  1813.  
  1814.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : constrain_scalar");
  1815.  
  1816.     constr_type = N_KIND(constraint);
  1817.     base_mark = (Symbol) base_type(type_mark);
  1818.     old_c = SIGNATURE(type_mark);
  1819.  
  1820.     if (constr_type == as_range) {
  1821.         /* In this case, the bounds expressions have not been
  1822.          * type-checked yet. Do it now that the desired base
  1823.          * type is known.
  1824.          */
  1825.         bt = root_type(type_mark);
  1826.         if (! is_scalar_type(bt)) {
  1827. #ifdef ERRNUM
  1828.             errmsgn(185, 164, constraint);
  1829. #else
  1830.             errmsg("Invalid RANGE constraint for type", "3.3, 3.6.1",
  1831.               constraint);
  1832. #endif
  1833.             return symbol_any;
  1834.         }
  1835.         lo = N_AST1(constraint);
  1836.         hi = N_AST2(constraint);
  1837.         check_type(base_mark, lo);
  1838.         check_type(base_mark, hi);
  1839.  
  1840.         constr = (int) numeric_constraint_kind(old_c);
  1841.         new_c = constraint_new(constr);
  1842.         numeric_constraint_low(new_c)  = (char *) lo;
  1843.         numeric_constraint_high(new_c) = (char *) hi;
  1844.  
  1845.         if (bt == symbol_float) {
  1846.             /* use digits specified for parent type  */
  1847.             numeric_constraint_digits(new_c) = numeric_constraint_digits(old_c);
  1848.         }
  1849.         else if (is_fixed_type(bt)) {
  1850.             numeric_constraint_delta(new_c) = numeric_constraint_delta(old_c);
  1851.             numeric_constraint_small(new_c) = numeric_constraint_small(old_c);
  1852.         }
  1853.     }
  1854.     else if (constr_type == as_digits  || constr_type== as_delta)     {
  1855.         kind = constr_type == as_digits ? symbol_float: symbol_dfixed;
  1856.         if (root_type(type_mark) != kind ) {
  1857. #ifdef ERRNUM
  1858.             errmsgn(186, 126, constraint);
  1859. #else
  1860.             errmsg("Invalid constraint for type", "3.3", constraint);
  1861. #endif
  1862.             return symbol_any;
  1863.         }
  1864.         /* if (is_generic_type(base_mark)) {
  1865.          * #ifdef ERRNUM
  1866.          *       errmsgn(187, 56, constraint);
  1867.          * #else
  1868.          *       errmsg("accurracy constraint cannot depend on a generic type",
  1869.          *       "12.1", constraint);
  1870.          * #endif
  1871.          *       return symbol_any;
  1872.          *     }
  1873.          */
  1874.         precision = N_AST1(constraint);
  1875.         range_constraint = N_AST2(constraint);
  1876.         base_precision = (Node) (SIGNATURE(type_mark))[4];
  1877.  
  1878.         if (is_generic_type(base_mark)) base_precision = precision;
  1879.         check_type((kind == symbol_float ? symbol_integer : symbol_real_type),
  1880.           precision);
  1881.  
  1882.         if (N_KIND(precision) == as_ivalue) {
  1883.             if (kind == symbol_float) {
  1884.                 digits = INTV((Const)N_VAL(precision));
  1885.                 if (digits < 1) {
  1886. #ifdef ERRNUM
  1887.                     errmsgn(188, 175, precision);
  1888. #else
  1889.                     errmsg("value for DIGITS must be positive", "3.5.7",
  1890.                       precision);
  1891. #endif
  1892.                 }
  1893.                 else if (digits > INTV((Const)N_VAL(base_precision))) {
  1894.                     warning(
  1895.                       "Evaluation of expression will raise CONSTRAINT_ERROR",
  1896.                       precision);
  1897.                 }
  1898.             }
  1899.             else {
  1900.                 delta = (Const) N_VAL(precision);
  1901.                 rdelta = RATV(delta);
  1902.                 /* need to declae [0, 1] as apropriate global ds 25 nov */
  1903.                 if (rat_lss(rdelta, rat_fri(int_fri(0), int_fri(1))))  {
  1904. #ifdef ERRNUM
  1905.                     errmsgn(189, 181, precision);
  1906. #else
  1907.                     errmsg("value of DELTA must be positive", "3.5.9",
  1908.                       precision);
  1909. #endif
  1910.                 }
  1911.                 /* TBSL: check translation of following    ds 26-nov-84*/
  1912.                 else if (rat_lss(rdelta, (RATV((Const)N_VAL(base_precision))))){
  1913.                     warning(
  1914.                       "Evaluation of expression will raise CONSTRAINT_ERROR",
  1915.                       precision);
  1916.                 }
  1917.             }
  1918.         }
  1919.         else {
  1920. #ifdef ERRNUM
  1921.             errmsgn(190, 191, precision);
  1922. #else
  1923.             errmsg("expect static expression for DIGITS or DELTA",
  1924.               "3.5.7, 3.5.9", precision);
  1925. #endif
  1926.         }
  1927.         if (range_constraint != OPT_NODE) {
  1928.             lo = N_AST1(range_constraint);
  1929.             hi = N_AST2(range_constraint);
  1930.             check_type(base_mark, lo);
  1931.             check_type(base_mark, hi);
  1932.         }
  1933.         else {
  1934.             /* Only the precision was given in the constraint. */
  1935.             /* Obtain the bounds from the type itself.*/
  1936.             lo = (Node) numeric_constraint_low(old_c);
  1937.             hi = (Node) numeric_constraint_high(old_c);
  1938.         }
  1939.  
  1940.         if (constr_type == as_digits) {
  1941.             new_c = constraint_new(CONSTRAINT_DIGITS);
  1942.             numeric_constraint_digits(new_c) = (char *) precision;
  1943.         }
  1944.         else {
  1945.             int jk;
  1946.             new_c = constraint_new(CONSTRAINT_DELTA);
  1947.             numeric_constraint_delta(new_c) = (char *) precision;
  1948.             jk = power_of_2((Const) N_VAL(precision));
  1949.             numeric_constraint_small(new_c) =  (char *)new_ivalue_node(
  1950.               rat_const(power_of_2_small), get_type(precision));
  1951.         }
  1952.         numeric_constraint_low(new_c)  = (char *) lo;
  1953.         numeric_constraint_high(new_c) = (char *) hi;
  1954.     }
  1955.     else if (constr_type == as_attribute) {
  1956.         /* The constraint is given by a RANGE attribute which is folded
  1957.          * as_attribute in adasem routine. We get the bounds of the 
  1958.          * range to construct the new subtype.
  1959.          */
  1960.         attr_node = N_AST1(constraint);
  1961.         if ((int)attribute_kind(constraint) != ATTR_RANGE) {
  1962. #ifdef ERRNUM
  1963.             errmsgn(125, 126, constraint);
  1964. #else
  1965.             errmsg("Invalid expression for range constraint","3.3", constraint);
  1966. #endif
  1967.             return symbol_any;
  1968.         }
  1969.         else {
  1970.             check_type(base_mark, constraint);
  1971.             new_c = apply_range(constraint);
  1972.         }
  1973.     }
  1974.     else {
  1975. #ifdef ERRNUM
  1976.         errmsgn(192, 193, constraint);
  1977. #else
  1978.         errmsg("Invalid constraint for scalar type", "3.3.2", constraint);
  1979. #endif
  1980.         return symbol_any;
  1981.     }
  1982.     /* Verify that a discriminant does not appear in a scalar constraint.
  1983.      * This must be special-cased because discriminants are otherwise
  1984.      * allowed to appear in index and discriminant constraints, and in
  1985.      * initial values, i.e. arbitrary expressions.
  1986.      */
  1987.     check_discriminant(constraint);
  1988.  
  1989.     typ = named_type(strjoin("&", newat_str()));   /* Create a name for it*/
  1990.     NATURE(typ) = na_subtype;
  1991.     TYPE_OF(typ) = type_mark;
  1992.     SIGNATURE(typ) = (Tuple) new_c;
  1993.     return typ;
  1994. }
  1995.